(*$R+,I-*)
PROGRAM LINKER;

CONST MAXSEG = 15;

TYPE SEGNUM = 0..MAXSEG;
     BLOCK0 = RECORD
		SEGDESC: ARRAY [SEGNUM] OF
			   RECORD
			     DISKADDR: INTEGER;
			     CODELENG: INTEGER
			   END;
		SEGNAME: ARRAY [SEGNUM] OF
			   PACKED ARRAY [0..7] OF CHAR;
		FILLER: PACKED ARRAY [1..320] OF CHAR
	      END;

VAR NBLOCKS,RSLT,OUTBLOCK: INTEGER;
    BUF: ^INTEGER;
    SEG: SEGNUM;
    TITLE: STRING;
    CODETBL: BLOCK0;
    CODE,INFILE: FILE;

FUNCTION CHECKIO:BOOLEAN;
VAR RSLT:INTEGER;
BEGIN
  CHECKIO:=IORESULT=0;
  IF IORESULT <> 0 THEN
    BEGIN
    RSLT:=IORESULT;
    WRITELN(OUTPUT,'I/O error # ',RSLT);
    END;
END; (* CHECKIO *)

FUNCTION OPENFILE: BOOLEAN;
BEGIN
  REPEAT
    WRITE(OUTPUT,'Link Code File? '); READLN(INPUT,TITLE);
    IF LENGTH(TITLE) > 0 THEN OPENOLD(INFILE,TITLE);
  UNTIL (CHECKIO) OR (LENGTH(TITLE) = 0);
  OPENFILE := LENGTH(TITLE) > 0
END (*OPENFILE*) ;

PROCEDURE LINKCODE;
  VAR NBLOCKS: INTEGER;
      INTBL: BLOCK0;

  FUNCTION CONFIRM:BOOLEAN;
  VAR CH:CHAR;
  BEGIN
    CONFIRM:=FALSE;
    WITH INTBL DO
      BEGIN
      IF SEGDESC[SEG].CODELENG > 24 THEN
	BEGIN
	WRITE(OUTPUT,'Linking ',SEGNAME[SEG],'.  Please Confirm (y/n)');
	READ(INPUT,CH);
	WRITELN(OUTPUT);
	IF (CODETBL.SEGDESC[SEG].CODELENG <> 0) AND (CH='Y') THEN
	  BEGIN
	  WRITE(OUTPUT,
'WARNING - This segment has already been linked in.  Please Reconfirm');
	  READ(INPUT,CH);
	  WRITELN(OUTPUT);
	  END;
	CONFIRM := CH = 'Y';
	END;
      END;
  END; (* CONFIRM *)

BEGIN
  IF BLOCKREAD(INFILE,INTBL,1,0) = 1 THEN
    BEGIN
      WITH INTBL DO
	FOR SEG := 0 TO MAXSEG DO
	    WITH SEGDESC[SEG] DO
	      IF CONFIRM THEN
		BEGIN NBLOCKS := (CODELENG+511) DIV 512;
		  IF BLOCKREAD(INFILE,BUF^,NBLOCKS,DISKADDR) <> NBLOCKS THEN
		    WRITELN(OUTPUT,'Error reading seg ',SEG)
		  ELSE
		    IF BLOCKWRITE(CODE,BUF^,NBLOCKS,OUTBLOCK) <> NBLOCKS THEN
		      WRITELN(OUTPUT,'I/O error - no room on disk')
		    ELSE
		      BEGIN
			WRITELN(OUTPUT,SEGNAME[SEG],' Seg # ',SEG,', Block ',
				OUTBLOCK,', ',CODELENG,' Bytes');
			CODETBL.SEGNAME[SEG] := SEGNAME[SEG];
			CODETBL.SEGDESC[SEG].CODELENG := CODELENG;
			CODETBL.SEGDESC[SEG].DISKADDR := OUTBLOCK;
			OUTBLOCK := OUTBLOCK + NBLOCKS
		      END
		END
    END
  ELSE
    BEGIN
    RSLT:=IORESULT;
    WRITELN(OUTPUT,'Input file read error # ',RSLT);
    END;
  CLOSE(INFILE)
END (*LINKCODE*) ;

BEGIN
  REPEAT
    WRITE(OUTPUT,'Output code file? '); READLN(INPUT,TITLE);
    IF LENGTH(TITLE) > 0 THEN OPENNEW(CODE,TITLE)
  UNTIL (LENGTH(TITLE) = 0) OR (CHECKIO);
  IF LENGTH(TITLE) > 0 THEN
      BEGIN OUTBLOCK := 1; NEW(BUF);
	WITH CODETBL DO
	  FOR SEG := 0 TO MAXSEG DO
	    BEGIN  SEGNAME[SEG] := '        ';
	      SEGDESC[SEG].CODELENG := 0;
	      SEGDESC[SEG].DISKADDR := 0
	    END;
	WHILE OPENFILE DO LINKCODE;
	IF BLOCKWRITE(CODE,CODETBL,1,0) = 1 THEN CLOSE(CODE,LOCK)
	ELSE
	  WRITELN(OUTPUT,'Code file write error ')
      END
END.
